home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-desktop-9.10-i386-PL.iso / casper / filesystem.squashfs / usr / bin / dpkg-divert < prev    next >
Text File  |  2009-09-20  |  11KB  |  354 lines
  1. #!/usr/bin/perl --
  2.  
  3. BEGIN { # Work-around for bug #479711 in perl
  4.     $ENV{PERL_DL_NONLAZY} = 1;
  5. }
  6.  
  7. use strict;
  8. use warnings;
  9.  
  10. use POSIX qw(:errno_h);
  11. use Dpkg;
  12. use Dpkg::Gettext;
  13.  
  14. textdomain("dpkg");
  15.  
  16. sub version {
  17.     printf _g("Debian %s version %s.\n"), $progname, $version;
  18.  
  19.     printf _g("
  20. Copyright (C) 1995 Ian Jackson.
  21. Copyright (C) 2000,2001 Wichert Akkerman.");
  22.  
  23.     printf _g("
  24. This is free software; see the GNU General Public Licence version 2 or
  25. later for copying conditions. There is NO warranty.
  26. ");
  27. }
  28.  
  29. sub usage {
  30.     printf(_g(
  31. "Usage: %s [<option> ...] <command>
  32.  
  33. Commands:
  34.   [--add] <file>           add a diversion.
  35.   --remove <file>          remove the diversion.
  36.   --list [<glob-pattern>]  show file diversions.
  37.   --listpackage <file>     show what package diverts the file.
  38.   --truename <file>        return the diverted file.
  39.  
  40. Options:
  41.   --package <package>      name of the package whose copy of <file> will not
  42.                              be diverted.
  43.   --local                  all packages' versions are diverted.
  44.   --divert <divert-to>     the name used by other packages' versions.
  45.   --rename                 actually move the file aside (or back).
  46.   --admindir <directory>   set the directory with the diversions file.
  47.   --test                   don't do anything, just demonstrate.
  48.   --quiet                  quiet operation, minimal output.
  49.   --help                   show this help message.
  50.   --version                show the version.
  51.  
  52. When adding, default is --local and --divert <original>.distrib.
  53. When removing, --package or --local and --divert must match if specified.
  54. Package preinst/postrm scripts should always specify --package and --divert.
  55. "), $progname);
  56. }
  57.  
  58. my $testmode = 0;
  59. my $dorename = 0;
  60. my $verbose = 1;
  61. my $mode = '';
  62. my $package = undef;
  63. my $divertto = undef;
  64. my @contest;
  65. my @altname;
  66. my @package;
  67. my $file;
  68. $|=1;
  69.  
  70.  
  71. # FIXME: those should be local.
  72. my ($rsrc, $rdest);
  73. my (@ssrc, @sdest);
  74.  
  75. sub checkmanymodes {
  76.     return unless $mode;
  77.     badusage(sprintf(_g("two commands specified: %s and --%s"), $_, $mode));
  78. }
  79.  
  80. while (@ARGV) {
  81.     $_= shift(@ARGV);
  82.     last if m/^--$/;
  83.     if (!m/^-/) {
  84.         unshift(@ARGV,$_); last;
  85.     } elsif (m/^--help$/) {
  86.         usage();
  87.         exit(0);
  88.     } elsif (m/^--version$/) {
  89.         version();
  90.         exit(0);
  91.     } elsif (m/^--test$/) {
  92.         $testmode= 1;
  93.     } elsif (m/^--rename$/) {
  94.         $dorename= 1;
  95.     } elsif (m/^--quiet$/) {
  96.         $verbose= 0;
  97.     } elsif (m/^--local$/) {
  98.         $package= ':';
  99.     } elsif (m/^--add$/) {
  100.         checkmanymodes();
  101.         $mode= 'add';
  102.     } elsif (m/^--remove$/) {
  103.         checkmanymodes();
  104.         $mode= 'remove';
  105.     } elsif (m/^--list$/) {
  106.         checkmanymodes();
  107.         $mode= 'list';
  108.     } elsif (m/^--listpackage$/) {
  109.         checkmanymodes();
  110.         $mode= 'listpackage';
  111.     } elsif (m/^--truename$/) {
  112.         checkmanymodes();
  113.         $mode= 'truename';
  114.     } elsif (m/^--divert$/) {
  115.         @ARGV || badusage(sprintf(_g("--%s needs a divert-to argument"), "divert"));
  116.         $divertto= shift(@ARGV);
  117.         $divertto =~ m/\n/ && badusage(_g("divert-to may not contain newlines"));
  118.     } elsif (m/^--package$/) {
  119.         @ARGV || badusage(sprintf(_g("--%s needs a <package> argument"), "package"));
  120.         $package= shift(@ARGV);
  121.         $package =~ m/\n/ && badusage(_g("package may not contain newlines"));
  122.     } elsif (m/^--admindir$/) {
  123.         @ARGV || badusage(sprintf(_g("--%s needs a <directory> argument"), "admindir"));
  124.         $admindir= shift(@ARGV);
  125.     } else {
  126.         badusage(sprintf(_g("unknown option \`%s'"), $_));
  127.     }
  128. }
  129.  
  130. $mode='add' unless $mode;
  131.  
  132. open(O, "$admindir/diversions") || quit(sprintf(_g("cannot open diversions: %s"), $!));
  133. while(<O>) {
  134.     s/\n$//; push(@contest,$_);
  135.     $_ = <O>;
  136.     s/\n$// || badfmt(_g("missing altname"));
  137.     push(@altname,$_);
  138.     $_ = <O>;
  139.     s/\n$// || badfmt(_g("missing package"));
  140.     push(@package,$_);
  141. }
  142. close(O);
  143.  
  144. if ($mode eq 'add') {
  145.     @ARGV == 1 || badusage(sprintf(_g("--%s needs a single argument"), "add"));
  146.     $file= $ARGV[0];
  147.     $file =~ m#^/# || badusage(sprintf(_g("filename \"%s\" is not absolute"), $file));
  148.     $file =~ m/\n/ && badusage(_g("file may not contain newlines"));
  149.     -d $file && badusage(_g("Cannot divert directories"));
  150.     $divertto= "$file.distrib" unless defined($divertto);
  151.     $divertto =~ m#^/# || badusage(sprintf(_g("filename \"%s\" is not absolute"), $divertto));
  152.     $package= ':' unless defined($package);
  153.     for (my $i = 0; $i <= $#contest; $i++) {
  154.         if ($contest[$i] eq $file || $altname[$i] eq $file ||
  155.             $contest[$i] eq $divertto || $altname[$i] eq $divertto) {
  156.             if ($contest[$i] eq $file && $altname[$i] eq $divertto &&
  157.                 $package[$i] eq $package) {
  158.                 printf(_g("Leaving \`%s'")."\n", infon($i)) if $verbose > 0;
  159.                 exit(0);
  160.             }
  161.             quit(sprintf(_g("\`%s' clashes with \`%s'"), infoa(), infon($i)));
  162.         }
  163.     }
  164.     push(@contest,$file);
  165.     push(@altname,$divertto);
  166.     push(@package,$package);
  167.     printf(_g("Adding \`%s'")."\n", infon($#contest)) if $verbose > 0;
  168.     checkrename($file, $divertto);
  169.     save();
  170.     dorename($file, $divertto);
  171.     exit(0);
  172. } elsif ($mode eq 'remove') {
  173.     @ARGV == 1 || badusage(sprintf(_g("--%s needs a single argument"), "remove"));
  174.     $file= $ARGV[0];
  175.     for (my $i = 0; $i <= $#contest; $i++) {
  176.         next unless $file eq $contest[$i];
  177.         quit(sprintf(_g("mismatch on divert-to\n  when removing \`%s'\n  found \`%s'"), infoa(), infon($i)))
  178.               if defined($divertto) && $altname[$i] ne $divertto;
  179.         quit(sprintf(_g("mismatch on package\n  when removing \`%s'\n  found \`%s'"), infoa(), infon($i)))
  180.               if defined($package) && $package[$i] ne $package;
  181.         printf(_g("Removing \`%s'")."\n", infon($i)) if $verbose > 0;
  182.         my $orgfile = $contest[$i];
  183.         my $orgdivertto = $altname[$i];
  184.         @contest= (($i > 0 ? @contest[0..$i-1] : ()),
  185.                    ($i < $#contest ? @contest[$i+1..$#contest] : ()));
  186.         @altname= (($i > 0 ? @altname[0..$i-1] : ()),
  187.                    ($i < $#altname ? @altname[$i+1..$#altname] : ()));
  188.         @package= (($i > 0 ? @package[0..$i-1] : ()),
  189.                    ($i < $#package ? @package[$i+1..$#package] : ()));
  190.         checkrename($orgdivertto, $orgfile);
  191.         dorename($orgdivertto, $orgfile);
  192.         save();
  193.         exit(0);
  194.     }
  195.     printf(_g("No diversion \`%s', none removed")."\n", infoa())
  196.         if $verbose > 0;
  197.     exit(0);
  198. } elsif ($mode eq 'list') {
  199.     my @list;
  200.     my @ilist = @ARGV ? @ARGV : ('*');
  201.     while (defined($_=shift(@ilist))) {
  202.         s/\W/\\$&/g;
  203.         s/\\\?/./g;
  204.         s/\\\*/.*/g;
  205.         push(@list,"^$_\$");
  206.     }
  207.     my $pat = join('|', @list);
  208.     for (my $i = 0; $i <= $#contest; $i++) {
  209.         next unless ($contest[$i] =~ m/$pat/o ||
  210.                      $altname[$i] =~ m/$pat/o ||
  211.                      $package[$i] =~ m/$pat/o);
  212.         print infon($i), "\n";
  213.     }
  214.     exit(0);
  215. } elsif ($mode eq 'truename') {
  216.     @ARGV == 1 || badusage(sprintf(_g("--%s needs a single argument"), "truename"));
  217.     $file= $ARGV[0];
  218.     for (my $i = 0; $i <= $#contest; $i++) {
  219.     next unless $file eq $contest[$i];
  220.     print $altname[$i], "\n";
  221.     exit(0);
  222.     }
  223.     print $file, "\n";
  224.     exit(0);
  225. } elsif ($mode eq 'listpackage') {
  226.     @ARGV == 1 || badusage(sprintf(_g("--%s needs a single argument"), $mode));
  227.     $file= $ARGV[0];
  228.     for (my $i = 0; $i <= $#contest; $i++) {
  229.     next unless $file eq $contest[$i];
  230.     if ($package[$i] eq ':') {
  231.         # indicate package is local using something not in package namespace
  232.         print "LOCAL\n";
  233.     } else {
  234.         print $package[$i], "\n";
  235.     }
  236.     exit(0);
  237.     }
  238.     # print nothing if file is not diverted
  239.     exit(0);
  240. } else {
  241.     quit(sprintf(_g("internal error - bad mode \`%s'"), $mode));
  242. }
  243.  
  244. sub infol {
  245.     return ((defined($_[2]) ? ($_[2] eq ':' ? "local " : "") : "any ").
  246.             "diversion of $_[0]".
  247.             (defined($_[1]) ? " to $_[1]" : "").
  248.             (defined($_[2]) && $_[2] ne ':' ? " by $_[2]" : ""));
  249. }
  250.  
  251. sub checkrename {
  252.     return unless $dorename;
  253.     ($rsrc,$rdest) = @_;
  254.     (@ssrc = lstat($rsrc)) || $! == ENOENT ||
  255.         quit(sprintf(_g("cannot stat old name \`%s': %s"), $rsrc, $!));
  256.     (@sdest = lstat($rdest)) || $! == ENOENT ||
  257.         quit(sprintf(_g("cannot stat new name \`%s': %s"), $rdest, $!));
  258.     # Unfortunately we have to check for write access in both
  259.     # places, just having +w is not enough, since people do
  260.     # mount things RO, and we need to fail before we start
  261.     # mucking around with things. So we open a file with the
  262.     # same name as the diversions but with an extension that
  263.     # (hopefully) wont overwrite anything. If it succeeds, we
  264.     # assume a writable filesystem.
  265.     if (open (TMP, ">>", "${rsrc}.dpkg-devert.tmp")) {
  266.     close TMP;
  267.     unlink ("${rsrc}.dpkg-devert.tmp");
  268.     } elsif ($! == ENOENT) {
  269.     $dorename = !$dorename;
  270.     # If the source file is not present and we are not going to do the
  271.     # rename anyway there's no point in checking the target.
  272.     return;
  273.     } else {
  274.     quit(sprintf(_g("error checking \`%s': %s"), $rsrc, $!));
  275.     }
  276.  
  277.     if (open (TMP, ">>", "${rdest}.dpkg-devert.tmp")) {
  278.     close TMP;
  279.     unlink ("${rdest}.dpkg-devert.tmp");
  280.     } else {
  281.     quit(sprintf(_g("error checking \`%s': %s"), $rdest, $!));
  282.     }
  283.     if (@ssrc && @sdest &&
  284.         !($ssrc[0] == $sdest[0] && $ssrc[1] == $sdest[1])) {
  285.         quit(sprintf(_g("rename involves overwriting \`%s' with\n".
  286.                         "  different file \`%s', not allowed"), $rdest, $rsrc));
  287.     }
  288. }
  289.  
  290. sub rename_mv($$)
  291. {
  292.     return (rename($_[0], $_[1]) || (system(("mv", $_[0], $_[1])) == 0));
  293. }
  294.  
  295. sub dorename {
  296.     return unless $dorename;
  297.     return if $testmode;
  298.     if (@ssrc) {
  299.         if (@sdest) {
  300.             unlink($rsrc) || quit(sprintf(_g("rename: remove duplicate old link \`%s': %s"), $rsrc, $!));
  301.         } else {
  302.             rename_mv($rsrc, $rdest) ||
  303.                 quit(sprintf(_g("rename: rename \`%s' to \`%s': %s"), $rsrc, $rdest, $!));
  304.         }
  305.     }
  306. }            
  307.     
  308. sub save {
  309.     return if $testmode;
  310.     open(N, "> $admindir/diversions-new") || quit(sprintf(_g("create diversions-new: %s"), $!));
  311.     chmod 0644, "$admindir/diversions-new";
  312.     for (my $i = 0; $i <= $#contest; $i++) {
  313.         print(N "$contest[$i]\n$altname[$i]\n$package[$i]\n")
  314.             || quit(sprintf(_g("write diversions-new: %s"), $!));
  315.     }
  316.     close(N) || quit(sprintf(_g("close diversions-new: %s"), $!));
  317.     unlink("$admindir/diversions-old") ||
  318.         $! == ENOENT || quit(sprintf(_g("remove old diversions-old: %s"), $!));
  319.     link("$admindir/diversions","$admindir/diversions-old") ||
  320.         $! == ENOENT || quit(sprintf(_g("create new diversions-old: %s"), $!));
  321.     rename("$admindir/diversions-new","$admindir/diversions")
  322.         || quit(sprintf(_g("install new diversions: %s"), $!));
  323. }
  324.  
  325. sub infoa
  326. {
  327.     infol($file, $divertto, $package);
  328. }
  329.  
  330. sub infon
  331. {
  332.     my $i = shift;
  333.     infol($contest[$i], $altname[$i], $package[$i]);
  334. }
  335.  
  336. sub quit
  337. {
  338.     printf STDERR "%s: %s\n", $progname, "@_";
  339.     exit(2);
  340. }
  341.  
  342. sub badusage
  343. {
  344.     printf STDERR "%s: %s\n\n", $progname, "@_";
  345.     usage();
  346.     exit(2);
  347. }
  348.  
  349. sub badfmt
  350. {
  351.     quit(sprintf(_g("internal error: %s corrupt: %s"), "$admindir/diversions", $_[0]));
  352. }
  353.  
  354.